The X-Philes (2nd Revision)/The X-Philes Number 1 (1995).iso/xphiles/hp48hor1/new2q.src

Text File | 1991-05-29 | 2KB | 64 lines

%%HP:T(3)F(.);
@ by the HP 48 Design Team
@
@ NEW2Q: Version of ->Q based on J.K.Horn's Algorithm [see DEC2FRAC on this
@ disk...  -jkh-], but uses exit conditions like those of ->Q.
@
@ Input:
@
@ 2: Decimal Number to be converted to a fraction
@ 1: Number of decimal places of zeros required in the error.
@
@ Output:
@
@ 1: 'Numerator/Denominator'
@
@ Example:
@
@ What's the simplest fraction which agrees with sqrt(3) to 4 decimal places?
@   3 √ 4 NEQ2Q returns '97/56'
@   '97/56-√3' EVAL returns .00009294957
@                                 ^^^^  note 4 zeros.
@
@

\<< -3 CF DUP2
  IF 1 > SWAP FP AND
  THEN OVER XPON 1 -                        @ calculate the input exponent.
    \<< \-> X 'IFTE(X==0,-500,XPON(X))' \>> @ define a 0-tolerant XPON.
  \-> f c x expo
    \<< 0 1 1 f DUP IP SWAP FP              @ set recursion initial cond.s.
      WHILE
       OVER 5 PICK / f - ABS expo EVAL      @ calculate expon. of error
       x SWAP - c <                         @ and compare with input.
       OVER AND                             @ if not close enough and
                                            @ the remainder's non-zero
      REPEAT
       INV DUP FP SWAP IP                   @ then calculate next iterate.
       \-> B0 B1 A0 A1 R B
        \<< B1 'B*B1+B0' EVAL
            A1 'B*A1+A0' EVAL
            R
        \>>
      END
      DROP SWAP DROP SWAP
      DUP 4 ROLL - DUP f * 0 RND            @ calc. "missing" den. and num.
      \-> N D D0 N0
      \<<
        IF 'x-expo(ABS(f-N0/D0))<c'         @ if "missing" frac. is not
        THEN N D                            @ good enough, use original.
        ELSE N0 D0
          IF 'N0\=/N'                       @ If it is really new,
          THEN 200 .2 BEEP                  @ then beep.
          END
        END
      \>>
    \>>                                     @ We're done, now clean up.
    IF DUP ABS 1 >
    THEN # 352318d SYSEVAL
    ELSE DROP
    END
  ELSE DROP
  END
\>>